;;;; RLlib copyright 2010 Adam White (theroguemonkey@gmail.com)
;;;; Licensed under GNU General Public Licence v2 or later - refer COPYING

(in-package #:rllib)

(defvar *screen* nil)
(defvar *screen-w* nil)
(defvar *screen-h* nil)
(defvar *mouse-adj* nil)

(cffi:defbitfield sdl-video-mode-flags
  (:swsurface          #x00000000)
  (:hwsurface          #x00000001)
  (:asyncblit          #x00000004)
  (:anyformat          #x10000000)
  (:hwpalette          #x20000000)
  (:doublebuf          #x40000000)
  (:fullscreen         #x80000000)
  (:opengl             #x00000002)
  (:openglblit         #x0000000A)
  (:resizable          #x00000010)
  (:noframe            #x00000020))

(cffi:defcfun ("SDL_SetVideoMode" sdl-set-video-mode) :pointer    
  (width :int)
  (height :int)
  (bpp :int)
  (flags sdl-video-mode-flags))

(cffi:defcfun ("SDL_GetVideoSurface" sdl-get-video-surface) :pointer)

(cffi:defcfun ("SDL_Flip" sdl-flip) :int
  (screen :pointer))


;;;============================================================================
;;; Events
;;;============================================================================

(cffi:defcenum sdl-event-type
  :idle
  :active-event
  :key-down
  :key-up
  :mouse-motion
  :button-down
  :button-up
  :joy-axis-motion
  :joy-ball-motion
  :joy-hat-motion
  :joy-button-down
  :joy-button-up
  :quit
  :sys-wm-event
  :event-reserved-a
  :event-reserved-b
  :video-resize
  :video-expose
  (:user 24))

(cffi:defbitfield sdl-keymod
  (:kmod-lshift     #x0001)
  (:kmod-rshift     #x0002)
  (:kmod-lctrl      #x0040)
  (:kmod-rctrl      #x0080)
  (:kmod-lalt       #x0100)
  (:kmod-ralt       #x0200)
  (:kmod-lmeta      #x0400)
  (:kmod-rmeta      #x0800)
  (:kmod-num        #x1000)
  (:kmod-caps       #x2000)
  (:kmod-mode       #x4000)
  (:kmod-reserved   #x8000))

(cffi:defcstruct sdl-keysym
  (scancode :uint8)
  (sym :int)
  (mod sdl-keymod)
  (unicode :uint16))

(defparameter *syms*
  (vector
   nil nil nil nil nil nil nil nil :backspace
   :tab nil nil :clear :return nil nil  nil nil nil
   :pause nil nil nil nil nil nil nil :escape nil
   nil nil nil  #\Space #\! #\" #\# #\$ nil #\&
   #\' #\( #\) #\* #\+ #\, #\- #\. #\/ #\0
   #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9 #\:
   #\; #\< #\= #\> #\? #\@ #\A #\B #\C #\D
   #\E #\F #\G #\H #\I #\J #\K #\L #\M #\N
   #\O #\P #\Q #\R #\S #\T #\U #\V #\W #\X
   #\Y #\Z #\[ #\\ #\] #\^ #\_ #\` #\a #\b
   #\c #\d #\e #\f #\g #\h #\i #\j #\k #\l
   #\m #\n #\o #\p #\q #\r #\s #\t #\u #\v
   #\w #\x #\y #\z nil nil nil nil :delete nil
   nil nil nil nil nil nil nil nil nil nil
   nil nil nil nil nil nil nil nil nil nil
   nil nil nil nil nil nil nil nil nil nil
   nil nil nil nil nil nil nil nil nil nil
   nil nil nil nil nil nil nil nil nil nil
   nil nil nil nil nil nil nil nil nil nil
   nil nil nil nil nil nil nil nil nil nil
   nil nil nil nil nil nil nil nil nil nil
   nil nil nil nil nil nil nil nil nil nil
   nil nil nil nil nil nil nil nil nil nil
   nil nil nil nil nil nil nil nil nil nil
   nil nil nil nil nil nil nil nil nil nil
   nil nil nil nil nil nil nil :kp0 :kp1 :kp2
   :kp3 :kp4 :kp5 :kp6 :kp7
   :kp8 :kp9 :kp. :kp/ :kp*
   :kp- :kp+ :kp-enter :kp= :up
   :down :right :left :insert :home
   :end :pageup :pagedown :f1 :f2
   :f3 :f4 :f5 :f6 :f7
   :f8 :f9 :f10 :f11 :f12
   :f13 :f14 :f15 nil nil
   nil :numlock :capslock :scrollock :rshift
   :lshift :rctrl :lctrl :ralt :lalt
   :rmeta :lmeta :lsuper :rsuper :mode
   :compose :help :print :sysreq :break
   :menu :power :euro :undo))

(defun sym->key (sym)
  (svref *syms* sym))

(cffi:defcstruct sdl-active-event
  (type :uint8)
  (gain :uint8)
  (state :uint8))

(cffi:defcstruct sdl-keyboard-event
  (type :uint8)
  (which :uint8)
  (state :uint8)
  (keysym sdl-keysym))
 
(cffi:defcstruct sdl-mouse-motion-event
  (type :uint8)
  (which :uint8)
  (state :uint8)
  (x :uint16)
  (y :uint16)
  (xrel :int16)
  (yrel :int16))

(cffi:defcstruct sdl-mouse-button-event
  (type :uint8)
  (which :uint8)
  (button :uint8)
  (state :int8)
  (x :uint16)
  (y :uint16))

(cffi:defcstruct sdl-joy-axis-event
  (type :uint8)
  (which :uint8)
  (axis :uint8)
  (value :int16))

(cffi:defcstruct sdl-joy-ball-event
  (type :uint8)
  (which :uint8)
  (ball :uint8)
  (xrel :int16)
  (yrel :int16))

(cffi:defcstruct sdl-joy-hat-event
  (type :uint8)
  (which :uint8)
  (hat :uint8)
  (value :uint8))

(cffi:defcstruct sdl-joy-button-event
  (type :uint8)
  (which :uint8)
  (button :uint8)
  (state :uint8))

(cffi:defcstruct sdl-resize-event
  (type :uint8)
  (w :int)
  (h :int))

(cffi:defcstruct sdl-expose-event
  (type :uint8))

(cffi:defcstruct sdl-quit-event
  (type :uint8))

(cffi:defcstruct sdl-user-event
  (type :uint8)
  (code :int)
  (data1 :pointer)
  (data2 :pointer))

(cffi:defcunion sdl-event
  (type :uint8)
  (active sdl-active-event)
  (sdl-keyboard-event sdl-keyboard-event)
  (sdl-mouse-motion-event sdl-mouse-motion-event)
  (sdl-mouse-button-event sdl-mouse-button-event)
  (sdl-joy-axis-event sdl-joy-axis-event)
  (sdl-joy-ball-event sdl-joy-ball-event)
  (sdl-joy-button-event sdl-joy-button-event)
  (sdl-resize-event sdl-resize-event)
  (sdl-expose-event sdl-expose-event)
  (quit sdl-quit-event)
  (user sdl-user-event))
 

(cffi:defcfun ("SDL_EnableUNICODE" %sdl-enable-unicode) :int
  (enable :int))

(defun sdl-enable-unicode ()
  (%sdl-enable-unicode 1))

(defun sdl-disable-unicode ()
  (%sdl-enable-unicode 0))


(cffi:defcfun ("SDL_EnableKeyRepeat" sdl-enable-key-repeat) :int
  (delay :int)
  (interval :int))

(cffi:defcfun ("SDL_GetKeyRepeat" sdl-get-key-repeat) :void
  (delay :pointer)
  (interval :pointer))


(defconstant +sdl-default-repeat-delay+ 500)
(defconstant +sdl-default-repeat-interval+ 30)


(cffi:defcfun ("SDL_GetModState" sdl-get-mod-state) sdl-keymod)

(let ((mod-hash (make-hash-table)))
  (loop for (mod conv) on '(:lshift :shift :rshift :shift
			    :kmod-lshift :shift :kmod-rshift :shift
			    :lalt :alt :ralt :alt
			    :kmod-lalt :alt :kmod-ralt :alt
			    :lctrl :ctrl :rctrl :ctrl
			    :kmod-lctrl :ctrl :kmod-rctrl :ctrl
			    :lmeta :meta :rmeta :meta
			    :kmod-lmeta :meta :kmod-rmeta :meta
			    :lsuper :super :rsuper :super)
       by #'cddr
       do (setf (gethash mod mod-hash) conv))

  (defun mods->set (mods sym)
    (delete-duplicates (mapcar (rcurry #'gethash mod-hash) (cons sym mods)))))



(cffi:defcfun ("SDL_GetKeyName" sdl-get-key-name) :string
  (key :int))




(cffi:defcfun ("SDL_PumpEvents" sdl-pump-events) :void)

(cffi:defcfun ("SDL_PollEvent" %sdl-poll-event) :int
  (event sdl-event))

(defun sdl-poll-event (cffi-event)
  (if (= 1 (%sdl-poll-event cffi-event))
      (cffi:foreign-slot-value cffi-event 'sdl-event 'type)
      0))

(cffi:defcfun ("SDL_WaitEvent" sdl-wait-event) :int
  (event sdl-event))

(cffi:defcfun ("SDL_PushEvent" sdl-push-event) :int
  (event sdl-event))


(cffi:defcfun ("SDL_EventState" %sdl-event-state) :uint8
  (type :uint8)
  (state :int))

(defun sdl-disable-event (type)
  (%sdl-event-state type 0))

(defun sdl-enable-event (type)
  (%sdl-event-state type 1))

(defun sdl-enable-event-p (type)
  (%sdl-event-state type -1))

(defmacro with-events ((&key) &body body)
  (let ((cffi-event (gensym "CFFI-EVENT-"))
	(event (gensym "TYPE-")))
    (labels ((fsv (ptr struct slot)
	       `(cffi:foreign-slot-value ,ptr ',struct ',slot))
	     (extract-event (event-type event-slot)
	       (fsv (fsv cffi-event 'sdl-event event-type) event-type event-slot))
	     (extract-keysym-struct (event-slot)
	       (fsv (extract-event 'sdl-keyboard-event 'keysym) 'sdl-keysym event-slot)))
      (let ((lambdas `(:key-down 
		       (:sym (sym->key ,(extract-keysym-struct 'sym))
			:mod (mods->set ,(extract-keysym-struct 'mod) (sym->key ,(extract-keysym-struct 'sym)))
			:unicode (code-char ,(extract-keysym-struct 'unicode)))
		     		   
		       :key-up
		       (:sym (sym->key ,(extract-keysym-struct 'sym))
			:mod (mods->set ,(extract-keysym-struct 'mod) (sym->key ,(extract-keysym-struct 'sym)))
			:unicode ,(extract-keysym-struct 'unicode))
		   
		       :mouse-motion
		       (:x ,(extract-event 'sdl-mouse-motion-event 'x)
			:y ,(extract-event 'sdl-mouse-motion-event 'y)
			:xrel ,(extract-event 'sdl-mouse-motion-event 'xrel)
			:yrel ,(extract-event 'sdl-mouse-motion-event 'yrel))
		   
		       :button-up
		       (:x ,(extract-event 'sdl-mouse-button-event 'x)
			:y ,(extract-event 'sdl-mouse-button-event 'y)
			:button ,(extract-event 'sdl-mouse-button-event 'button))
		   
		       :button-down
		       (:x ,(extract-event 'sdl-mouse-button-event 'x)
			:y ,(extract-event 'sdl-mouse-button-event 'y)
			:button ,(extract-event 'sdl-mouse-button-event 'button))
		   
		       :video-resize
		       (:width ,(extract-event 'sdl-resize-event 'w)
			:height ,(extract-event 'sdl-resize-event 'h))
		   
		       :joy-axis
		       (:axis ,(extract-event 'sdl-joy-axis-event 'axis)
			:value ,(extract-event 'sdl-joy-axis-event 'value)) 
		   
		       :joy-ball
		       (:ball ,(extract-event 'sdl-joy-ball-event 'ball)
			:xrel ,(extract-event 'sdl-joy-ball-event 'xrel)
			:yrel ,(extract-event 'sdl-joy-ball-event 'yrel))
		   
		       :joy-hat
		       (:hat ,(extract-event 'sdl-joy-hat-event 'hat)
			:value ,(extract-event 'sdl-joy-hat-event 'value))
		   
		       :joy-button-down
		       (:button ,(extract-event 'sdl-joy-button-event 'button))

		       :joy-button-up
		       (:button ,(extract-event 'sdl-joy-button-event 'button))
		     
		       :video-expose
		       ()
		   
		       :quit
		       ()
		   
		       :user
		       (:code ,(extract-event 'sdl-user-event 'code)
			:data1 ,(extract-event 'sdl-user-event 'data1)
			:data2 ,(extract-event 'sdl-user-event 'data2)))))

	(let ((idle nil))
	  (flet ((expand-filters (events)
		   (loop for ev in events collect
			`(sdl-enable-event ,(cffi:foreign-enum-value 'sdl-event-type ev))))
		 
		 (expand-idle (idle)
		   `((t ,@idle)))
		 
		 (expand-clause (clause)
		   (when (eq (car clause) :idle)
		     (setf idle (cddr clause))
		     (return-from expand-clause nil))
		   (let* ((type (car clause))
			  (plist (cadr clause))
			  (body (cddr clause))
			  (accessors (getf lambdas type))
			  ;; only used for error reporting
			  (type-keys (loop for i in lambdas by #'cddr collect i))
			  (plist-keys (loop for i in plist by #'cddr collect i))
			  (acc-keys (loop for i in accessors by #'cddr collect i))
			  (set-dif (set-difference plist-keys acc-keys)))
		     
		     ;; make-cell sure accessors are all legit
		     (unless (member type type-keys)
		       (error "Illegal ~S. Allowed ~S" type type-keys))
		     (when set-dif
		       (error "Illegal ~S accessors ~S. Allowed ~S" type set-dif acc-keys))
		     ;; dump a LET form binding vars to their event-struct values
		     (list (cffi:foreign-enum-value 'sdl-event-type type)
			   (cond
			     ((eq type :video-expose)
			      (caddr clause))
			     ((eq type :quit)
			      `(progn
				,(caddr clause)
				(return)))
			     (t
			      `(let ,(loop for (keyword var) on plist by #'cddr
					collect (list var (getf accessors keyword)))
				,@body)))))))
	
	    `(progn
	      (loop for event from 1 below 32 do (sdl-disable-event event))
	      ,@(expand-filters (mapcar #'car body))
	      (cffi:with-foreign-object (,cffi-event 'sdl-event)
		(loop
		   for ,event = (sdl-poll-event ,cffi-event) do		     
		   (case ,event
		     ;; since saving :idle until last leaves a NIL in
		     ;; the stream, we need to remove it via delete
		     ,@(delete nil (append (mapcar #'expand-clause body) (expand-idle idle))))))
	      )
	    ))))))
  
  


;;;============================================================================
;;; Mouse
;;;============================================================================

(cffi:defcfun ("SDL_WarpMouse" sdl-warp-mouse) :void
  (x :uint16)
  (y :uint16))

(cffi:defcfun ("SDL_ShowCursor" %sdl-show-cursor) :int
  (toggle :int))

(cffi:defcfun ("SDL_GetMouseState" %sdl-get-mouse-state) :uint8
  (x :pointer)
  (y :pointer))


(defun sdl-get-mouse-position ()
  (cffi:with-foreign-objects ((x :int) (y :int))
    (%sdl-get-mouse-state x y)
    (list (cffi:mem-ref x :int) (cffi:mem-ref y :int))))

(defun sdl-show-cursor ()
  (%sdl-show-cursor 1))

(defun sdl-hide-cursor ()
  (%sdl-show-cursor 0))

(defun sdl-cursor-shown-p ()
  (plusp (%sdl-show-cursor -1)))

(cffi:defcenum sdl-gl-attr
  :gl-red-size
  :gl-green-size
  :gl-blue-size
  :gl-alpha-size
  :gl-buffer-size
  :gl-doublebuffer
  :gl-depth-size
  :gl-stencil-size
  :gl-accum-red-size
  :gl-accum-green-size
  :gl-accum-blue-size
  :gl-accum-alpha-size
  :gl-stereo
  :gl-multisamplebuffers
  :gl-multisamplesamples
  :gl-accelerated-visual
  :gl-swap-control)

(cffi:defcfun ("SDL_SetGamma" sdl-set-gamma) :int
  (red :float)
  (green :float)
  (blue :float))

(cffi:defcfun ("SDL_GL_SetAttribute" sdl-gl-set-attribute) :int
  (attr sdl-gl-attr)
  (val :int))

(cffi:defcfun ("SDL_GL_SwapBuffers" sdl-gl-swap-buffers) :void)


;;;============================================================================
;;; WM Funcs
;;;============================================================================

(cffi:defcfun ("SDL_WM_SetCaption" sdl-wm-set-caption) :void
  (title :string)
  (icon :pointer))

(cffi:defcfun ("SDL_WM_IconifyWindow" sdl-wm-iconify-window) :int)

(cffi:defcfun ("SDL_WM_ToggleFullScreen" sdl-wm-toggle-fullscreen) :int
  (surface :pointer))

(cffi:defcfun ("SDL_WM_GrabInput" %sdl-wm-grab-input) :int
  (mode :int))

(defun sdl-wm-grab-input (grab)
  (%sdl-wm-grab-input (if grab 1 0)))

(defun sdl-wm-grab-input-p ()
  (plusp (%sdl-wm-grab-input -1)))



;;;============================================================================
;;; Init
;;;============================================================================

(cffi:defbitfield sdl-init-flags
  (:init-timer          #x00000001)
  (:init-audio          #x00000010)
  (:init-video          #x00000020)
  (:init-cdrom          #x00000100)
  (:init-joystick       #x00000200)
  (:init-noparachute    #x00100000)
  (:init-eventthread    #x01000000)
  (:init-everything     #x0000ffff))

(cffi:defcfun ("SDL_Init" sdl-init) :int
  (flags sdl-init-flags))

(cffi:defcfun ("SDL_InitSubSystem" sdl-init-subsystem) :int
  (flags sdl-init-flags))

(cffi:defcfun ("SDL_QuitSubSystem" sdl-quit-subsystem) :void
  (flags sdl-init-flags))

(cffi:defcfun ("SDL_WasInit" sdl-was-init) :uint32
  (flags sdl-init-flags))

(cffi:defcfun ("SDL_Quit" sdl-quit) :void)
